Ham Radio 2000 #1/Ham Radio 2000.iso/ham2000/misc/worldmap/mapvu20/mapgraph.pas

Pascal/Delphi Source File | 1989-01-11 | 22.6 KB | 610 lines

Unit mapgraph; { low level graphics routines for MAPVIEW.PAS                 }

{ Copyright A.J. van den Bogert and Gisbert W.Selke Dec 1988                 }

{$UNDEF  DEBUG }                    { DEFINE while debugging }

{$IFDEF DEBUG }
{$A+,R+,S+,I+,D+,F-,V-,B-,L+ }
{$ELSE }
{$A+,R-,S-,I+,D-,F-,V-,B-,L+ }
{$ENDIF }
{$M 65520,0,560000 }

{$IFDEF CPU87 }
{$N+ }
{$ELSE }
{$N- }
{$ENDIF }

Interface

Uses Dos, Crt, Graph;

{$IFOPT N+ }
Type real = single;
{$ENDIF }

Const currversion = 2;                  { current version of file format }
      uparr  = #72;                     { code of up arrow }
      dnarr  = #80;                     { code of down arrow }
      lfarr  = #75;                     { code of left arrow }
      rtarr  = #77;                     { code of right arrow }
      cuparr = #141;                    { maybe code of control-up arrow }
      cdnarr = #145;                    { maybe code of control-down arrow }
      clfarr = #115;                    { code of control-left arrow }
      crtarr = #116;                    { code of control-right arrow }
      ctrlc  = #3;                      { code of control-c }
      esc    = #27;                     { code of escape }
      cr     = #13;                     { code of carriage return }
      bksp   = #8;                      { code of backspace }

Type scrfile = file;                    { screen save file type }
     picdesc = Record                   { screen file header record }
                 version, follow : byte;
                 grdriver, grmode : integer;
                 size : word;
                 xmin, ymin : integer;
               End;
     scrsav  = Record                   { screen save record }
                 size : word;
                 vptr : pointer;
               End;

Var xmaxpix, ymaxpix : integer;         { minimum and maximum coordinates }
    aspect : real;                      { aspect ratio of x and y pixels }
    colourglb, maxcolour : word;        { current colour, maximum colour }
    thisgraphdriver, thisgraphmode : integer; { current graphics mode }

Procedure initgraphic;                  { prepare graphics }
Procedure leavegraphic;                 { shut down graphics }
Procedure newgraphmode(grm : integer);  { set non-standard graphics mode }
Procedure logo(title,subtitle:string);  { show logo }
Procedure erasescreen;                  { erase entire graphics screen }
Procedure preservescreen;               { save screen for later re-use }
Procedure restorescreen;                { restore previously saved screen }
Procedure hline(iy: integer);           { draw a horizontal full length line }
Procedure vline(ix: integer);           { draw a vertical full length line }
Procedure dotline(x1, y1, x2, y2 : integer; Var dotflag : boolean);
                                        { draw a dotted line }
Procedure unprompt;                     { remove prompt made by prompt }
Procedure prompt(t : string);           { display a prompt }
Function  confirmquit(t:string):boolean;{ confirm something }
Function  checkuser : boolean;          { check for user interaction }
Procedure showmsg(t : string);          { show informative message }
Procedure errmsg(t : string);           { show error message }
Procedure showprogress(what : byte);    { show a sign of progress top right }
Procedure save(Var screenfile:scrfile); { save complete screen to file }
Procedure scrprint(prno, nrep : byte);  { print screen on Epson-type printer }
Function  intext(Var t : string; maxlg : byte) : boolean;
                  { read a string of given max length during graphics mode; }
                  { return True if no special key was hit }

Implementation

Const maxchunk = 10;       { maximum number of chunks of a screen }

Type scrpak = Record
                size : word;
                xmin, xmax : integer;
                vptr : pointer;
              End;

Var savrec : scrsav;
    psc : Array [1..maxchunk] Of scrpak;
    nchunk : byte;
    tw, th, ltrsiz, hlinsiz, vlinsiz : word;
    isput : boolean;
    hlinpic, vlinpic, curspic, nilpic, smilepic : pointer;

Procedure initgraphic;
{ prepare for graphics, clear screen                                         }
  Var grerrcode, axmax, savxmax : integer;
      xasp, yasp, isiz : word;

  Procedure initpics;
  { initialize image buffers for lines and graphics text input cursor        }
  Begin                                                           { initpics }
    Line(0,0,xmaxpix,0);
    hlinsiz := ImageSize(0,0,xmaxpix,1); { some bug in TP 4.0 requires }
    GetMem(hlinpic,hlinsiz);             { height > 1                  }
    If hlinpic <> Nil Then GetImage(0,0,xmaxpix,1,hlinpic^);
    Line(0,0,0,ymaxpix);
    vlinsiz := ImageSize(0,0,0,ymaxpix); { width = 1 seems OK, though }
    GetMem(vlinpic,vlinsiz);
    If vlinpic <> Nil Then GetImage(0,0,0,ymaxpix,vlinpic^);
    ClearDevice;
    tw := TextWidth('M');
    th := TextHeight('Ap');
    ltrsiz := ImageSize(0,0,tw,th);
    GetMem(curspic,ltrsiz);
    GetMem(nilpic,ltrsiz);
    GetMem(smilepic,ltrsiz);
    If nilpic <> Nil Then GetImage(0,0,tw,th,nilpic^);
    SetFillStyle(CloseDotFill,GetMaxColor);
    Bar(0,0,tw,th);
    If curspic <> Nil Then GetImage(0,0,tw,th,curspic^);
    ClearDevice;
    outtextxy(0,0,#2);
    If smilepic <> Nil Then GetImage(0,0,tw,th,smilepic^);
    ClearDevice;
  End;                                                            { initpics }

  Procedure memerror;
  { notify user that memory is not sufficient to preserve pictures           }
    Var ch : char;
  Begin                                                           { memerror }
    RestoreCRTMode;
    writeln('Your system has not enough free memory for preserving MapView ',
            'pictures.');
    writeln('Hence, pictures will be erased on certain commands.');
    writeln('Try to remove some resident programmes you have loaded,');
    writeln('or switch to a lower resolution graphics mode before the ',
            'next run.');
    ch := ReadKey;
    SetGraphMode(thisgraphmode);
    axmax := xmaxpix;
  End;                                                            { memerror }

Begin                                                          { initgraphic }
  thisgraphdriver := Detect;
  initgraph(thisgraphdriver,thisgraphmode,'');
  grerrcode := GraphResult;
  If grerrcode <> 0 Then
  Begin
    writeln('Graphics error:',GraphErrorMsg(grerrcode));
    Halt(1);
  End;
  SetTextStyle(DefaultFont,HorizDir,1);
  ClearDevice;
  xmaxpix := GetMaxX;
  ymaxpix := GetMaxY;
  GetAspectRatio(xasp,yasp);
  aspect := yasp / xasp;
  maxcolour := GetMaxColor;
  colourglb := maxcolour; { start plotting WHITE }
  SetColor(colourglb);
  initpics;
  savrec.vptr := Nil;
  nchunk := 0;
  Repeat
    Inc(nchunk);
    isiz := ImageSize(0,0,xmaxpix Div nchunk,ymaxpix);
  Until (isiz > 0) And (isiz <= 65521);
  savxmax := xmaxpix Div nchunk;
  axmax := -1;
  nchunk := 0;
  Repeat
    Inc(nchunk);
    With psc[nchunk] Do
    Begin
      xmin := Succ(axmax);
      axmax := xmin + savxmax;
      If axmax > xmaxpix Then axmax := xmaxpix;
      xmax := axmax;
      size := ImageSize(xmin,0,xmax,ymaxpix);
      GetMem(vptr,size);
      If vptr = Nil Then memerror;
    End;
  Until axmax >= xmaxpix;
End;                                                           { initgraphic }

Procedure newgraphmode(grm : integer);
{ set different graphics mode, if admissible; otherwise set highest          }
{ graphics mode possible                                                     }
  Var lomode, himode : integer;
Begin                                                         { newgraphmode }
  GetModeRange(thisgraphdriver,lomode,himode);
  If grm < lomode Then grm := lomode;
  If grm < himode Then grm := himode;
  SetGraphMode(grm);
  thisgraphmode := grm;
End;                                                          { newgraphmode }

Procedure leavegraphic;
{ shut down graphics, clear screen                                           }
  Var i : byte;
Begin                                                         { leavegraphic }
  CloseGraph;
  If hlinpic  <> Nil Then FreeMem(hlinpic,hlinsiz);
  If vlinpic  <> Nil Then FreeMem(vlinpic,vlinsiz);
  If curspic  <> Nil Then FreeMem(curspic,ltrsiz);
  If nilpic   <> Nil Then FreeMem(nilpic,ltrsiz);
  If smilepic <> Nil Then FreeMem(smilepic,ltrsiz);
  For i := 1 To nchunk Do FreeMem(psc[i].vptr,psc[i].size);
  thisgraphdriver := -1;
  thisgraphmode   := -1;
End;                                                          { leavegraphic }

Procedure logo(title, subtitle : string);
{ display logo                                                               }
Begin                                                                 { logo }
  SetTextStyle(DefaultFont,HorizDir,7);
  OutTextXY((xmaxpix-TextWidth(title)) Div 2,ymaxpix Div 3,title);
  SetTextStyle(DefaultFont,HorizDir,1);
  OutTextXY((xmaxpix-TextWidth(subtitle)) Div 2,(2*ymaxpix) Div 3,subtitle);
End;                                                                  { logo }

Procedure erasescreen;
{ blank screen                                                               }
Begin                                                          { erasescreen }
  SetViewPort(0,0,xmaxpix,ymaxpix,True);
  ClearViewPort;
End;                                                           { erasescreen }

Procedure preservescreen;
{ preserve current graphics screen for later restore                         }
  Var i : byte;
Begin                                                       { preservescreen }
  SetViewPort(0,0,xmaxpix,ymaxpix,True);
  For i := 1 To nchunk Do With psc[i] Do
      If vptr <> Nil Then GetImage(xmin,0,xmax,ymaxpix,vptr^);
End;                                                        { preservescreen }

Procedure restorescreen;
{ restore graphics screen previously saved                                   }
  Var i : byte;
Begin                                                        { restorescreen }
  SetGraphMode(GetGraphMode);
  SetViewPort(0,0,xmaxpix,ymaxpix,True);
  For i := 1 To nchunk Do With psc[i] Do
           If vptr <> Nil Then PutImage(xmin,0,vptr^,NormalPut);
End;                                                         { restorescreen }

Procedure hline(iy: integer);
{ put full-width horizontal line on screen                                   }
Begin                                                                { hline }
  PutImage(0,iy,hlinpic^,XOrPut);
End;                                                                 { hline }

Procedure vline(ix: integer);
{ put full-height vertical line on screen                                    }
Begin                                                                { vline }
  PutImage(ix,0,vlinpic^,XOrPut);
End;                                                                 { vline }

Procedure dotline(x1, y1, x2, y2 : integer; Var dotflag : boolean);
{ draw a dotted line seamlessly extending a previous dotted one              }
  Var deltax, deltay, xstep, ystep, direction : integer;
Begin                                                              { dotline }
  If x1 <= x2 Then xstep := 1 Else xstep := -1;
  If y1 <= y2 Then ystep := 1 Else ystep := -1;
  deltax := Abs(x2 - x1);
  deltay := Abs(y2 - y1);
  If deltax = 0 Then direction := -1 Else direction := 0;
  While Not ((x1 = x2) and (y1 = y2)) Do
  Begin
    If dotflag Then PutPixel(x1,y1,colourglb);
    dotflag := Not dotflag;
    If direction < 0 Then
    Begin
      y1 := y1 + ystep;
      direction := direction + deltax;
    End
    Else
    Begin
      x1 := x1 + xstep;
      direction := direction - deltay;
    End;
  End;
End;                                                               { dotline }

Procedure unprompt;
{ remove prompt from screen                                                  }
Begin                                                             { unprompt }
  With savrec Do
  Begin
    If vptr <> Nil Then
    Begin
      SetViewPort(0,0,xmaxpix,ymaxpix,True);
      PutImage(0,0,vptr^,NormalPut);
      FreeMem(vptr,size);
    End;
    vptr := Nil;
  End;
End;                                                              { unprompt }

Procedure prompt(t : string);
{ prompt user on graphics screen                                             }
  Var ht, lg : word;
Begin                                                               { prompt }
  unprompt;
  With savrec Do
  Begin
    ht := TextHeight(t);  lg := TextWidth(t);
    size := ImageSize(0,0,lg,ht);
    GetMem(vptr,size);
    If vptr <> Nil Then GetImage(0,0,lg,ht,vptr^);
    SetViewPort(0,0,lg,ht,True);
    ClearViewPort;
    outtext(t);
    SetViewPort(0,0,xmaxpix,ymaxpix,True);
  End;
End;                                                                { prompt }

Function confirmquit(t : string) : boolean;
{ asks user if s/he relly wants to quit                                      }
  Var ch : char;
Begin                                                          { confirmquit }
  prompt(t);
  Repeat
    ch := UpCase(ReadKey);
  Until ch In [esc,ctrlc,'Y','N'];
  confirmquit := ch In [esc,ctrlc,'Y'];
  unprompt;
End;                                                           { confirmquit }

Function checkuser : boolean;
{ check if user rang                                                         }
  Var ch : char;
Begin                                                            { checkuser }
  If KeyPressed Then
  Begin
    ch := UpCase(ReadKey);
    If Not (ch In ['Q',esc,ctrlc]) Then
    Begin
      Repeat Until KeyPressed;
      ch := UpCase(ReadKey);
    End;
    If ch In ['Q',esc,ctrlc] Then
             checkuser := confirmquit('Do you really want to quit?');
  End Else checkuser := False;
End;                                                             { checkuser }

Procedure showmsg(t : string);
{ show message in prompt line; wait for key to be hit                        }
  Var ch : char;
Begin                                                              { showmsg }
  prompt(t);
  ch := ReadKey;
End;                                                               { showmsg }

Procedure errmsg(t : string);
{ display an error message                                                   }
Begin                                                               { errmsg }
  Sound(440);
  Delay(200);
  NoSound;
  showmsg(t);
End;                                                                { errmsg }

Procedure showprogress(what : byte);
{ if what = 0 : save lower right corner for later restore                    }
{         = 1 : show a sign of progress in upper right corner of screen      }
{ otherwise   :  restore original contents                                   }
Begin                                                         { showprogress }
  Case what Of
    0 : Begin
          PutImage(xmaxpix-tw,ymaxpix-th,smilepic^,NormalPut);
          isput := True;
        End;
    1 : Begin
          PutImage(xmaxpix-tw,ymaxpix-th,smilepic^,XOrPut);
          isput := Not isput;
        End;
   Else If isput Then PutImage(xmaxpix-tw,ymaxpix-th,smilepic^,XOrPut);
  End;
End;                                                          { showprogress }

Procedure save(Var screenfile:scrfile);
{ save screen on disk file - uses same buffer as preservescreen              }
   Var picd : picdesc;
       i : byte;
       axmax, savxmax : integer;
Begin                                                                 { save }
  savxmax := xmaxpix Div nchunk;
  axmax := -1;
  i := 0;
  Repeat
    Inc(i);
    With picd Do
    Begin
      version  := currversion;
      follow   := nchunk - i;
      grdriver := thisgraphdriver;
      grmode   := thisgraphmode;
      xmin     := Succ(axmax);
      ymin     := 0;
      axmax    := xmin + savxmax;
      If axmax > xmaxpix Then axmax := xmaxpix;
      size     := ImageSize(xmin,0,axmax,ymaxpix);
      GetImage(xmin,0,axmax,ymaxpix,psc[1].vptr^);
    End;
    {$I- } BlockWrite(screenfile,picd,SizeOf(picd));
    BlockWrite(screenfile,psc[1].vptr^,picd.size); {$I+ }
  Until axmax >= xmaxpix;
  If IOResult <> 0 Then
  Begin
    prompt('Some I/O error occurred - save may have gone awry!');
    i := Ord(ReadKey);
    unprompt;
  End;
End;                                                                  { save }

Procedure scrprint(prno, nrep : byte);
{ hardcopy of Hercules screen on STAR NL10 or Epson FX type printers         }
{ prno : number of printer port (1..4)                                       }
{ nrep : number of times each line is overprinted                            }

  Const errormask = $29;
        intpr = $17;

  Var i, symaxpix, prmax, portno : word;
      continue : boolean;
      bytebuf : Array [1..2000] Of byte;
      regs : Registers;

  Function checkprinter : boolean;
  { check printer status; if not ready, holler at user. Accept 'quit' command }
    Var quitit : boolean;
  Begin                                                       { checkprinter }
    quitit := False;
    With regs Do
    Begin
      Repeat
        ah := 2;
        dx := portno;
        Intr(intpr,regs);
        If (ah And errormask) <> 0 Then
        Begin
          prompt('Please, check the printer!');
          quitit := UpCase(Readkey) In ['Q',ctrlc,esc];
          unprompt;
        End;
      Until ((ah And errormask) = 0) Or quitit;
    End;
    checkprinter := Not quitit;
  End;                                                        { checkprinter }

  Procedure printbyte(byt : byte);
  { output a single byte to printer port                                     }
  Begin                                                          { printbyte }
    If continue Then
    Begin
      With regs Do
      Begin
        ah := $00;
        al := byt;
        dx := portno;
        Intr(intpr,regs);
        If (ah And errormask) <> 0 Then continue := checkprinter;
      End;
    End;
  End;                                                           { printbyte }

  Procedure prinit;
  { initialize printer and set to proper linefeed                            }
  Begin                                                             { prinit }
    With regs Do
    Begin
      ah := $01;
      dx := portno;
      Intr(intpr,regs);
    End;
    printbyte(27);   { Esc'3'#24 : set linefeed to 24/180 " }
    printbyte(51);
    printbyte(24);
    printbyte(10);   { tighten paper }
  End;                                                              { prinit }

  Procedure doline(top, i : integer);
  { prepare a single printer line                                            }

    Var rep, j : integer;

    Function ConstructByte(j, i : integer) : byte;
    { construct a single byte of a printer line                              }
      Const bits : Array [0..7] Of byte = (128,64,32,16,8,4,2,1);
      Var CByte, k : byte;
    Begin                                                    { constructbyte }
      i := i Shl 3;
      cbyte := 0;
      For k := 0 To top Do
        If GetPixel(j,i+k) <> Black Then cbyte := cbyte Or bits[k];
      constructbyte := cbyte;
    End;                                                     { constructbyte }

  Begin                                                             { doline }
    If continue Then
    Begin
      For j := 0 To xmaxpix Do bytebuf[j+6] := constructbyte(j,i);
      {$I- }
      For rep := 1 To nrep Do
      Begin
        For j := 1 To prmax Do printbyte(bytebuf[j]);
        printbyte(13);
      End;
      printbyte(10);
      {$I+ }
    End;
  End;                                                              { doline }

Begin                                                             { scrprint }
  If (prno >= 1) And (prno <= 4) Then portno := Pred(prno) Else portno := 0;
  symaxpix := Succ(ymaxpix);
  continue := checkprinter;
  If Not continue Then Exit;
  prinit;
  {$I- }
  i := Succ(xmaxpix);
  bytebuf[1] := 27;       { Esc'*'#6.. : select screen graphics mode }
  bytebuf[2] := 42;
  bytebuf[3] :=  6;
  bytebuf[4] := Lo(i);
  bytebuf[5] := Hi(i);
  prmax := xmaxpix + 6;
  For i := 0 To Pred(symaxpix Shr 3) Do doline(7,i);
  If symaxpix And 7 <> 0 Then doline(symaxpix and 7,symaxpix Shr 3);
  If Not checkprinter Then Exit;
  printbyte(27);          { Esc'2' : reset to normal linefeed }
  printbyte(50);
  {$I+ }
  If IOResult <> 0 Then
  Begin
    prompt('Some I/O error occurred - hardcopy may have gone awry!');
    i := Ord(ReadKey);
    unprompt;
  End;
End;                                                              { scrprint }

Function intext(Var t : string; maxlg : byte) : boolean;
{read a line (max length: maxlg) of kbd input in graphics mode               }
  Var c : char;
      arrowkey : boolean;
      curlg, ht, clg, lg, size : word;
      vptri : pointer;
Begin                                                               { intext }
  SetViewPort(0,0,xmaxpix,ymaxpix,True);
  ht := TextHeight('Ap');
  clg := TextWidth('M');
  lg := maxlg * clg;
  size := ImageSize(0,ht,lg,ht+ht);
  GetMem(vptri,size);
  If vptri <> Nil Then GetImage(0,ht,lg,ht+ht,vptri^);
  SetViewPort(0,ht,lg,ht+ht,True);
  ClearViewPort;
  t := '';
  curlg := 0;
  arrowkey := False;
  Repeat
    PutImage(curlg*clg,0,curspic^,NormalPut);
    c := ReadKey;
    PutImage(curlg*clg,0,nilpic^,NormalPut);
    Case c Of
     '!'..'~' : Begin
                  outtextxy(curlg*clg,0,c);
                  t := t + c;
                  Inc(curlg);
                End;
     bksp : If curlg > 0 Then
            Begin
              PutImage(Pred(curlg)*clg,0,nilpic^,NormalPut);
              delete(t,curlg,1);
              Dec(curlg);
          End;
      #0 : Begin
             c := ReadKey;
             arrowkey := (t = '') And
             (c In [lfarr,rtarr,uparr,dnarr,clfarr,crtarr,cuparr,cdnarr]);
           End;
    End;
  Until (length(t) = maxlg) Or (c In [ctrlc,cr,esc]) Or arrowkey;
  If c In [ctrlc,esc] Then t := '';
  intext := Not arrowkey;
  SetViewPort(0,0,xmaxpix,ymaxpix,True);
  If vptri <> Nil Then PutImage(0,ht,vptri^,NormalPut);
  If vptri <> Nil Then FreeMem(vptri,size);
End;                                                                { intext }

Begin                                 { initialization part of unit mapgraph }
  xmaxpix  := 0;
  ymaxpix  := 0;
  aspect   := 0.0;
  nchunk   := 0;
  hlinpic  := Nil;
  vlinpic  := Nil;
  curspic  := Nil;
  nilpic   := Nil;
  smilepic := Nil;
End.                                                              { mapgraph }